perm filename CNTOUR[1,BGB] blob
sn#021805 filedate 1973-02-23 generic text, type T, neo UTF8
00100 SUBR(THRESH)------------------------------------------------------
00200 BEGIN THRESH;THRESHOLD(LEVEL) pre foonly version. BGB 4 DEC 1972.
00300 SKIPE FLGKRK↔DETSEG
00400 ;SOUBIT TO PAC FOR PIXELS ≥ CUT.
00500 I←13 ↔ J←14
00600 CALL(SEGTV)
00700 LAC [XWD L,2]↔BLT 13
00800 LAC ARG1↔DAC HCUT
00900 LAP 5,ARG1
01000 GO 3
01100
01200 ;ACCUMULATOR LOOP.
01300 L: POINT 6,TVBUF,-1
01400 MOVEI J,=36 ;3
01500 ILDB 2 ;4
01600 SUBI ;CUT ;5
01700 ROTC 1 ;6
01800 SOJG J,4 ;7
01900 SETCAM 1,PAC(I) ;10
02000 AOBJN I,3 ;11
02100 POP1J ;12
02200 XWD -=1728,0 ;13
02300 BEND;12/17/72-----------------------------------------------------
02400
02500 HCUT: 0 ;HCUT GLOBAL FROM THRESH TO MKPGONS.
02600
02700 SUBR(PACXOR)------------------------------------------------------
02800 BEGIN PACXOR;do rook's exclusive OR'ing. BGB 4-DEC-72.
02900 I←2
03000 SLACI PAC↔LAPI HSEG↔BLT HSEG+=1727
03100 SLACI PAC↔LAPI VSEG↔BLT VSEG+=1727
03200 SETZ I,
03300 HRRI PAC↔DAP L+2
03400 L: TRNN I,7↔SETZ 1,↔LAC PAC(I)
03500 XORM HSEG+8(I) ; HSEG SOUBIT are above PAC bits.
03600 ROTC -1↔ROT 1,1
03700 XORM VSEG(I) ; VSEG are left of PAC bits.
03800 AOS I
03900 CAIE I,=1728
04000 GO L
04100 SETZM ISAVED
04200 POP0J
04300 BEND;12/4/72------------------------------------------------------
04400
00100 SUBR(HISTOG)---------------------------------------------------
00200 BEGIN HISTOG;MAKE HISTOGRAM OF TVBUF - BGB - 4 DEC 72.
00300
00400 CALL(SEGTV)
00500 SKIPE FTVHIS↔POP0J↔SETOM FTVHIS
00600 LAC[XWD HISTO,HISTO+1]↔SETZM HISTO↔BLT HISTO+77
00700 LAC 7,[XWD L,0]↔BLT 7,6↔GO 2
00800
00900 ;ACCUMULATOR LOOP.
01000 L: =62208 ;0
01100 0 ;1
01200 ILDB 1,6 ;2
01300 AOS HISTO(1) ;3
01400 SOJG 0,2 ;4
01500 POP0J ;5
01600 POINT 6,TVBUF,-1;6
01700
01800 BEND;12/16/72-----------------------------------------------------
00100 SUBR(MKPGON)LEVEL--------------------------------------------------
00200 BEGIN MKPGON;MAKE AN INTENSITY CONTOUR POLYGON - BGB - AUGUST 1972.
00300
00400 ACCUMULATORS{A2,A3,RC.,MASK,I,PTR,D,E,V,PG,BITQ,H1,H2}
00500 LAC H1,HCUT↔LSH H1,-3↔LACI H2,7↔SUB H2,H1
00600 LAC I,ISAVED↔CDR PTR,ARG1↔LACI BITQ,VREL
00700 SLACI I↔HRRI PAC↔DAC PACPTR#; PAC POINTER INDEXED BY I.
00800
00900 ;FIND THE ROW & COL OF THE UPPER LEFT MOST VSEG.
01000 L1: SKIPE 1,VSEG(I)↔GO L2
01100 AOS I↔CAIE I,=1728↔GO L1
01200 SETZ 1,↔POP1J;EMPTY.
01300
01400 L2: DAC I,ISAVED↔JFFO 1,.+1↔SLACI MASK,400000
01500 MOVNS 2↔LSH MASK,(2)↔MOVNS 2
01600 LAC RC.,I↔ANDI RC.,7↔IMULI RC.,=36↔ADD RC.,2 ;COLUMN.
01700 LAC I↔LSH -3↔DIP RC.↔LSH RC.,6 ;ROW.
01800
01900 ;DISTINGUISH BLOBS FROM HOLES.
02000 SETZM HOLE#
02100 TDNN MASK,@PACPTR ;HOLE OR BLOB ?
02200 SETOM HOLE# ;HOLE'A'COMING.
02300 SKIPE HOLE↔EXCH H1,H2
02400
02500 ;AND HEAD SOUTH.
02600
02700 SETQ(PG,{MAKE,[PBIT+PGNREL]})
02800 LAC 0,ARG1↔DAD. 0,PG↔CALL(RINGIN,PG,0)
02900 SKIPE HOLE↔GO[MARK PG,HOLBIT↔GO .+1]
03000 DAC RC.,RCMIN#
03100 SETZM RCMAX#
03200 SETZ V,↔SETZM ECNT#
03300 PUSHJ P,FOLLOW
03400 LAC V,V0
03500 CCW. V,E↔CW. E,V
03600
03700 ;MAKE & RETURN VIC POLYGON.
03800
03900 LAC 1,ECNT↔SKIPE HOLE#↔MOVNS 1
04000 NCNT. 1,PG
04100 LAC V0↔SON. 0,PG ;UPPER MOST LEFT.
04200 ; LAC V1↔ARC. 0,PG ;LOWER MOST RIGHT.
04300 LAC 1,PG
04400 L3: POP1J
00100 ;THE SUB-OPERATIONS OF MKPGON.
00200
00300 DEFINE TRY (SEG,YES) {
00400 LAC SEG(I)↔TDZN MASK↔GO .+3↔DAC SEG(I)↔GO YES}
00500 DEFINE LEFT {SUBI RC.,100↔ROT MASK,1↔CAIN MASK,1↔SOS I}
00600 DEFINE RIGHT {ADDI RC.,100↔ROT MASK,-1↔SKIPG MASK↔AOS I}
00700 DEFINE UP {SUB RC.,[1B11]↔SUBI I,8}
00800 DEFINE DOWN {ADD RC.,[1B11]↔ADDI I,8}
00900
01000 ;CREATE NEW EDGE AND VERTEX OF A VIC.
01100 TURN: 0
01200 AOS TURNS#
01300 ADD D,RC.
01400 AOS 2,ECNT
01500
01600 ;VERTEX
01700 CALL MAKE,BITQ
01800 PGON. PG,1
01900 SKIPN V↔GO[DAC 1,V0#↔DAC 1,V↔GO T2]
02000 DAC 1,V
02100 CCW. V,E↔CW. E,V
02200 T2: DAC D,RC(V)
02300 CAMLE D,RCMAX
02400 GO[DAC D,RCMAX↔DAC V,V1#↔GO .+1]
02500 DAC V,E
02600 GO @TURN
00100 ;THE ALCHEMIST OF MKPGON - converts bits of lead into lines of gold.
00200
00300 NORTH: ADD D,[1B11]↔LIPI BITQ,(NORBIT+VBIT)↔JSR TURN
00400 NORTH2: LEFT↔LAC D,DELPM(H1)↔ TRY HSEG,WEST
00500 RIGHT↔UP↔ TRY VSEG,NORTH2
00600 DOWN↔LAC D,DELPP(H2)↔ TRY HSEG,EAST↔FATAL(NORTH)
00700 NORTH3: LIPI BITQ,(NORBIT+VBIT)↔JSR TURN↔LEFT
00800 NORTH4: UP↔LAC D,DELPM(H1)↔ TRY HSEG,WEST↔GO NORTH4
00900
01000
01100 WEST: ADDI D,100↔LIPI BITQ,(WESBIT+VBIT)↔JSR TURN
01200 WEST2: CAMN RC.,RCMIN↔POPJ P,;TRY FOR E.O.VIC.
01300 FOLLOW: LAC D,DELPP(H1)↔ TRY VSEG,SOUTH
01400 LEFT↔ TRY HSEG,WEST2
01500 RIGHT↔UP↔LAC D,DELMP(H2)↔TRY VSEG,NORTH↔FATAL(WEST)
01600
01700
01800 SOUTH: LIPI BITQ,(SOUBIT+VBIT)↔JSR TURN
01900 SOUTH2: DOWN↔LAC D,DELMP(H1)
02000 CAR RC.↔CAIN =216B29↔GO EAST3
02100 TRY HSEG, EAST
02200 TRY VSEG,SOUTH2
02300 LEFT↔LAC D,DELMM(H2)↔ TRY HSEG,WEST↔ FATAL(SOUTH)
02400
02500
02600 EAST: LIPI BITQ,(EASBIT+VBIT)↔JSR TURN
02700 EAST2: RIGHT↔LAC D,DELMM(H1)
02800 CDR RC.↔CAIN =288B29↔GO NORTH3
02900 UP↔ TRY VSEG,NORTH
03000 DOWN↔ TRY HSEG,EAST2
03100 LAC D,DELPM(H2)↔ TRY VSEG,SOUTH↔FATAL(EAST)
03200 EAST3: LIPI BITQ,(EASBIT+VBIT)↔JSR TURN↔UP
03300 EAST4: RIGHT↔LAC D,DELMM(H1)
03400 CDR RC.↔CAIN =288B29↔GO[DOWN↔GO NORTH3]
03500 TRY VSEG,NORTH↔GO EAST4
03600
03700 ;DEKINKING OFF SETS.
03800 DELPP: FOR I←24,33{XWD I,I↔}
03900 DELPM: FOR I←24,33{XWD I,-I↔}
04000 DELMP: FOR I←24,33{XWD -I,I↔}
04100 DELMM: FOR I←24,33{XWD -I,-I↔}
04200
04300 BEND;12/14/72-----------------------------------------------------